CD ROM Paradise Collection 4/CD ROM Paradise Collection 4 1995 Nov.iso/program/swags_z.zip/STRINGS.SWG/0081_General String Library.pas

Pascal/Delphi Source File | 1994-05-26 | 22.8 KB | 622 lines

UNIT STR_STF;
  {**------------------------------------------------**}
  {**    STRING Library OPERATIONS                   **}
  {**    Version 1.2                                 **}
  {**            Added Pos_Reverse                   **}
  {**    Version 1.1 (sped-ups)                      **}
  {**                (delete_duplicate_Chars_in_str) **}
  {**            Added Int_To_Str_Zero_Fill          **}
  {**------------------------------------------------**}

{$O-,F+}

INTERFACE
{**************************************************************}
{* Trim   removes leading/trailing blanks.                    *}
{*                                                            *}
{**************************************************************}
FUNCTION TRIM        (Str : string) : string;

FUNCTION TRIM_Leading_Only (Str : string) : string;
FUNCTION TRIM_Trailing_Only (Str : string) : string;
FUNCTION TRIM_Quotes (Str : string) : string;

{**************************************************************}
{* Right_Justify adds leading blanks.                         *}
{*    NOTE: does not handle cases when                        *}
{*                   Size_To_Be < ACTUAL NUMBER OF CHARACTERS *}
{**************************************************************}
FUNCTION Right_Justify (Str : string; Size_To_Be : integer) : string;

{***************************************************************}
{* Center_Str   centers the characters in the string based     *}
{*              upon the size/midpoint specified.              *}
{***************************************************************}
FUNCTION Center_Str (Str : string; Output_Size : integer) : string;

{**************************************************************}
{* Change_Case changes the case of the string to UPPER.       *}
{*                                                            *}
{**************************************************************}
FUNCTION CHANGE_CASE (Str : string) : string;
FUNCTION Lower_Case (Str : string) : string;

{**************************************************************}
{* Int_To_Str returns the number converted into ascii chars.  *}
{*                                                            *}
{**************************************************************}
FUNCTION Int_To_Str  (Num : LongInt) : string;
FUNCTION Int_To_Str_Zero_Fill  (Num : LongInt; Fill : byte) : string;
FUNCTION Int_Num_Digits (Num : LongInt) : integer;

{**************************************************************}
{* Pos_Reverse returns the last occurance of the string       *}
{*     just before the specified start pos!                   *}
{**************************************************************}
FUNCTION Pos_Reverse (Str        : string;
                      Delimiter  : string;
                      Start_At   : integer) : integer;

{**************************************************************}
{* Find_Char   returns the position of the char               *}
{*                                                            *}
{**************************************************************}
FUNCTION Find_Char   (Str      : string;
                      Char_Is  : char;
                      Start_At : integer) : INTEGER;

{**************************************************************}
{* Delete_The_Char   delete all occurances of the char        *}
{*                                                            *}
{**************************************************************}
FUNCTION Delete_The_Char
                     (Str      : string;
                      Char_Is  : char) : string;

{**************************************************************}
{* Replace_Str_Into  inserts the small string into the        *}
{*                   org_str at the position specified        *}
{**************************************************************}
FUNCTION Replace_Str_Into (Org_Str     : String;
                           Small_Str   : string;
                           Start, Stop : integer) : string;

{**************************************************************}
{* procedure Get_Word_Around_Position                         *}
{*     returns the word based AROUND the position specified   *}
{*     Searches for blanks around the start_pos               *}
{*        looking left then right.                            *}
{**************************************************************}
function Get_Word_Around_Position
                     (Str                    : string;
                      Start_Pos              : integer;
                      Leftmost_Char_Boundry  : integer;
                      Rightmost_Char_Boundry : integer;
                      VAR Found_Left_Pos     : integer;
                      VAR Found_Word_Size    : integer) : string;

{**************************************************************}
{* returns a string with duplicate chars deleted.             *}
{**************************************************************}
function Delete_Duplicate_Chars_In_Str (Str            : string;
                                        Limit_In_A_Row : byte): string;

{**************************************************************}
{* returns a string filled with the character specified       *}
{**************************************************************}
function Fill_String(Len : Byte; Ch : Char) : String;

{**************************************************************}
{* Truncates a string to a specified length                   *}
{**************************************************************}
function Trunc_Str(TString : String; Len : Byte) : String;

{**************************************************************}
{* Pads a string to a specified length with a specified character }
{**************************************************************}
function Pad_Char(PString : String; Ch : Char; Len : Byte) : String;


{**************************************************************}
{* Left-justify a string within a certain width               *}
{**************************************************************}
function Left_Justify_Str (S : String; Width : Byte) : String;


{**************************************************************}
{* Note that "Count" is the number of *WORDS* to fill.        *}
{* So e.g. you'd use                                          *}
{* "FillWord(My_Int_Array, SizeOf(My_Int_Array) DIV 2, 1);"   *}
{*      by Neil Rubenking                                     *}
{**************************************************************}
PROCEDURE FillWord (VAR Dest; Count, What : Word);


{**************************************************************}
{**************************************************************}
{**************************************************************}
IMPLEMENTATION

{**************************************************************************}
function Min(N1, N2 : Longint) : Longint;
{ Returns the smaller of two numbers }
begin
  if N1 <= N2 then
    Min := N1
  else
    Min := N2;
end; { Min }

(*
{**************************************************************************}
function Max(N1, N2 : Longint) : Longint;
{ Returns the larger of two numbers }
begin
  if N1 >= N2 then
    Max := N1
  else
    Max := N2;
end; { Max }
*)

{**************************************************************}
{* returns a string filled with the character specified       *}
{**************************************************************}
function Fill_String(Len : Byte; Ch : Char) : String;
var
  S : String;
begin
  IF (Len > 0) THEN
    BEGIN
      S[0] := Chr(Len);
      FillChar(S[1], Len, Ch);
      Fill_String := S;
    END
  ELSE Fill_String := '';
end; { FillString }

{**************************************************************}
{* Truncates a string to a specified length                   *}
{**************************************************************}
function Trunc_Str(TString : String; Len : Byte) : String;
begin
  if (Length(TString) > Len) then
    begin
      {Delete(TString, Succ(Len), Length(TString) - Len);}
      {Move(TString[Succ(Len)+(LENGTH(TString)-Len)], TString[Succ(Len)],
           Succ(Length(TString)) - Succ(Len) - Length(TString) - Len));}
      Move(TString[LENGTH(TString)+1], TString[Succ(Len)], 2*Len);
      Dec(TString[0], Length(TString) - Len);
    end;
  Str_Stf.Trunc_Str := TString;
end; { TruncStr }

{**************************************************************}
{* Pads a string to a specified length with a specified character }
{**************************************************************}
function Pad_Char(PString : String; Ch : Char; Len : Byte) : String;
var
  CurrLen : Byte;
begin
  CurrLen := Min(Length(PString), Len);
  PString[0] := Chr(Len);
  FillChar(PString[Succ(CurrLen)], Len - CurrLen, Ch);
  Pad_Char := PString;
end; { PadChar }

{**************************************************************}
{* Left-justify a string within a certain width               *}
{**************************************************************}
function Left_Justify_Str(S : String; Width : Byte) : String;
begin
  Left_Justify_Str := Str_Stf.Pad_Char(S, ' ', Width);
end; { Left_Justify_Str }

{**************************************************************}
{* Trim   removes leading/trailing blanks.                    *}
{*                                                            *}
{**************************************************************}
FUNCTION TRIM (Str : string) : string;
VAR
  i : integer;
BEGIN
  i := 1;
  WHILE ((i < LENGTH(Str)) and (Str[i] = ' '))
    DO INC(i);

  IF (i > 1) THEN
    BEGIN
      {Str := COPY (Str, i, Length(Str));}
      Move (Str[i], Str[1], Succ(LENGTH(Str))-i);
      DEC (Str[0], pred(i));
    END;

  WHILE (Str[LENGTH(str)] = ' ')
    DO DEC (Str[0]);

  Trim := Str;
END;  {trim}

{**************************************************************}
{* Trim_Lead   removes leading blanks.                        *}
{*                                                            *}
{**************************************************************}
FUNCTION TRIM_Leading_Only (Str : string) : string;
VAR
  i : integer;
BEGIN
  i := 1;
  WHILE ((i < LENGTH(Str)) and (Str[i] = ' '))
    DO INC(i);

  IF (i > 1) THEN
    BEGIN
      {Str := COPY (Str, i, Length(Str));}
      Move (Str[i], Str[1], Succ(LENGTH(Str))-i);
      DEC (Str[0], pred(i));
    END;

  Trim_Leading_Only := Str;
END;  {trim_leading_Only}

{***************************************************************}
FUNCTION TRIM_Trailing_Only (Str : string) : string;
BEGIN
  WHILE (Str[LENGTH(str)] = ' ')
    DO DEC (Str[0]);

  Trim_Trailing_Only := Str;
END;  {trim}

{***************************************************************}
{*------------------------------------------------------*}
{* Trim off any lead/trail quotes!                      *}
{*------------------------------------------------------*}
FUNCTION TRIM_Quotes (Str : string) : string;
begin
  IF ((LENGTH(Str) > 0) and (Str[1] = '"')) THEN
    BEGIN
      Move (Str[2], Str[1], pred(LENGTH(Str)));
      DEC (Str[0]);
      IF (Str[LENGTH(Str)] = '"')
        THEN DEC(Str[0]);
    END; {if}
Trim_Quotes := Str;
end; {Trim_Quotes}

{***************************************************************}
{* Right_Justify adds leading blanks.                          *}
{*    NOTE: does not handle cases when                         *}
{*                    Size_To_Be < ACTUAL NUMBER OF CHARACTERS *}
{***************************************************************}
FUNCTION Right_Justify (Str : string; Size_To_Be : integer) : string;
VAR
  Temp_Str  : string;
BEGIN
  Temp_Str := TRIM (Str);   {to assure proper length--and NON-BLANK}
  Right_Justify := Str_Stf.Left_Justify_Str
                               ('', Size_To_Be - Length(Str)) + Str;

{  WHILE ((LENGTH(Temp_Str) > 0) AND
         ( (Size_To_Be > LENGTH (Temp_Str)) OR
           (Temp_Str[Size_To_Be] = ' ') ) )
    DO Temp_Str := ' '+ COPY (Temp_Str, 1, Size_To_Be-1);
  Right_Justify := Temp_Str;}

END; {right_justify}

{***************************************************************}
{* Center_Str   centers the characters in the string based     *}
{*              upon the size/midpoint specified.              *}
{***************************************************************}
FUNCTION Center_Str (Str : string; Output_Size : integer) : string;
VAR
  Ret_Str : string;
  Size    : integer;
BEGIN
  { blank out returning string}
  Ret_Str := Str_Stf.Fill_String(Output_Size, ' ');
  {FillChar (Ret_Str, output_size, ' ');
   Ret_Str[0] := chr(Output_Size);}

  Str := TRIM (Str);
  Size := LENGTH (Str);
  IF (Output_Size <= Size)
    THEN Ret_Str := Str
  ELSE
    BEGIN
      Insert (Str, Ret_Str, (((Output_Size - Size) div 2)+1));
      Ret_Str := COPY (Ret_Str, 1, OutPut_Size);
    END;
  Center_Str := Ret_Str;
END; {center_str}

{**************************************************************}
{* Change_Case changes the case of the string to UPPER.       *}
{*                                                            *}
{**************************************************************}
FUNCTION Change_Case (Str : string) : string;
var
  i : integer;
BEGIN
  for i := 1 to LENGTH (Str)
    do Str[i] := UpCase(Str[i]);
  Change_Case := Str;
END;  {change_case}

{**************************************************************}
FUNCTION Lower_Case (Str : string) : string;
var
  i : integer;
BEGIN
  for i := 1 to LENGTH (Str)
    do IF ((ORD (Str[i]) >= 65) and (ORD(Str[i]) <= 90))
         THEN Str[i] := CHR(ORD(Str[i])+32);
  Lower_Case := Str;
END;  {lower_case}

{**************************************************************}
{* Int_To_Str returns the number converted into ascii chars.  *}
{*                                                            *}
{**************************************************************}
FUNCTION Int_To_Str  (Num : LongInt) : string;
var
  Temp_Str : string;
BEGIN
  STR(Num, Temp_Str);
  Int_To_Str := Temp_Str;
END; {int_to_str}

FUNCTION Int_To_Str_Zero_Fill  (Num : LongInt; Fill : byte) : string;
var
  Temp_Str : string;
  Len : byte;
BEGIN
  STR(Num, Temp_Str);
  Len := LENGTH(Temp_Str);
  IF (Len < Fill)
    THEN Temp_Str := Fill_String(Fill-Len, '0')+Temp_Str;
  Int_To_Str_Zero_Fill := Temp_Str;
END; {int_to_str_zero_fill}

FUNCTION Int_Num_Digits (Num : LongInt) : integer;
var
 Tens, Digits : Integer;
BEGIN
  IF (Num = 0)
    THEN Int_Num_Digits := 1
  ELSE
    BEGIN
      Tens := 1;
      Digits := 1;
      WHILE ((Num DIV Tens) <> 0) DO
      BEGIN
        INC (Digits);
        Tens := Tens * 10;
      END; {while}

      IF (Digits > 1)
        THEN DEC (Digits);
      Int_Num_Digits := Digits;
    END; {if}

END; {int_num_digits}

{**************************************************************}
{* Pos_Reverse returns the last occurance of the string       *}
{*     just before the specified start pos!                   *}
{**************************************************************}
FUNCTION Pos_Reverse (Str        : string;
                      Delimiter  : string;
                      Start_At   : integer) : integer;
VAR
  Temp_Str : string;
  Found_Pos, Found_Pos_0 : integer;
BEGIN
  Temp_Str := COPY(Str, 1, Start_At);  {dont use move since ?start_at <length?}
  Found_Pos_0 := 0;
  REPEAT
    Found_Pos := POS (Delimiter, Temp_Str);
    IF (Found_Pos <> 0) THEN
      BEGIN
        Found_Pos_0 := Found_Pos_0+Found_Pos;
        {Temp_Str := COPY(Temp_Str, Found_Pos+1, LENGTH(Temp_Str));}
        Move (Temp_Str[Found_Pos+1], Temp_Str[1], LENGTH(Str)-Found_Pos+2);
        DEC (Temp_Str[0], Found_Pos);
      END;
  UNTIL (Found_Pos = 0);
  Pos_Reverse := Found_Pos_0;
END; {pos_reverse}

{**************************************************************}
{* Find_Char   returns the position of the char               *}
{*                                                            *}
{**************************************************************}
FUNCTION Find_Char (Str      : string;
                    Char_Is  : char;
                    Start_At : integer) : INTEGER;
VAR
  Loc : integer;
BEGIN
  Loc := POS (Char_Is, COPY(Str, Start_At, LENGTH(STR)));
  IF (Loc <> 0)
    THEN Loc := Loc + Start_At -1;
  Find_Char := Loc;
END; {function Find_Char}

{**************************************************************}
{* Delete_The_Char   delete all occurances of the char        *}
{*                                                            *}
{**************************************************************}
FUNCTION Delete_The_Char (Str      : string;
                          Char_Is  : char) : string;
VAR
  Loc : integer;
BEGIN
  Loc := 0;
  REPEAT
    Loc := POS (Char_Is, Str);
    IF (Loc <> 0) THEN
      BEGIN
        {DELETE (Str, Loc, 1);}
        Move(Str[Succ(Loc)], Str[Loc], Length(Str)-Loc);
        Dec(Str[0]);
      END;
  UNTIL (Loc = 0);

  Delete_The_Char := STR;
END; {function Delete_The_Char}

{**************************************************************}
{* Replace_Str_Into  inserts the small string into the        *}
{*                   org_str at the position specified        *}
{**************************************************************}
FUNCTION Replace_Str_Into (Org_Str     : String;
                           Small_Str   : string;
                           Start, Stop : integer) : string;
var
  Temp_Small_Str : string;
begin
  IF (Start = 0)
    THEN Start := 1;

  IF (LENGTH(Small_Str) >= (Stop-Start+1))
    THEN Temp_Small_Str := Small_Str
  ELSE Temp_Small_Str := Small_Str +
                       Fill_String ( (Stop-Start+1-LENGTH(Small_Str)), ' ');
  IF (Start > 1)
    THEN Replace_Str_Into := Copy (Org_Str, 1, (Start -1)) +
                             Copy (Temp_Small_Str, 1, (Stop-Start+1))+
                             Copy (Org_Str, (Stop+1) , LENGTH(Org_Str))
    ELSE Replace_Str_Into := Copy (Temp_Small_Str, 1, (Stop-Start+1)) +
                             Copy (Org_Str, Stop+1, LENGTH(Org_Str));
end; {Replace_Str_into}

{**************************************************************}
{* procedure Get_Word_Around_Position                         *}
{*     returns the word based AROUND the position specified   *}
{*     Searches for blanks around the start_pos               *}
{*        looking left then right.                            *}
{**************************************************************}
function Get_Word_Around_Position
                               (Str                    : string;
                                Start_Pos              : integer;
                                Leftmost_Char_Boundry  : integer;
                                Rightmost_Char_Boundry : integer;
                                VAR Found_Left_Pos     : integer;
                                VAR Found_Word_Size    : integer) : string;
var
  adjust         : integer;

begin
  IF ((Start_Pos <= LENGTH(Str))) THEN
    BEGIN
      Get_Word_Around_Position := Str[Start_Pos];
      Found_Left_Pos := Start_Pos;
      Found_Word_Size := 1;
    END

  ELSE        {* Bad Params! *}
    BEGIN
      Get_Word_Around_Position := ' ';
      Found_Left_Pos           := 0;
      Found_Word_Size          := 0;
      Exit;
    END;

  if (Str[Start_Pos] <> ' ') then
    begin
      {************************************************}
      {*  FIRST: find left-most position              *}
      {************************************************}
      adjust := Start_Pos -1;
      while ((adjust >= leftmost_char_boundry) and
             (Str[adjust] <> ' '))
        do adjust := adjust - 1;
      if ((adjust = leftmost_char_boundry) and (Str[adjust] <> ' '))
        then Found_Left_Pos := adjust
        else Found_Left_Pos := adjust +1;

      {************************************************}
      {*  find right-most position                    *}
      {************************************************}
      adjust := Start_Pos +1;
      while ((adjust <= Rightmost_Char_Boundry) and
              (Str[adjust] <> ' '))
        do adjust := adjust + 1;

      if ((adjust = Rightmost_char_boundry) and (Str[adjust] <> ' '))
        then Found_Word_Size := adjust - Found_Left_Pos +1
        else Found_Word_Size := adjust - Found_Left_Pos;

      Get_Word_Around_Position := Copy (Str, Found_Left_Pos, Found_Word_Size);

    end; {if}

end; {get_word_around_position}

{**************************************************************}
{* returns a string with duplicate chars deleted.             *}
{**************************************************************}
function Delete_Duplicate_Chars_In_Str (Str            : string;
                                        Limit_In_A_Row : byte) : string;
var
  Curr_Pos       : integer;
  i              : integer;
  Same_Chars     : boolean;
begin

  IF (Limit_In_A_Row = 1) THEN       {* must catch or infinite loop *}
    BEGIN
      Delete_Duplicate_Chars_In_Str := '';
      exit;
    END;

  Curr_Pos        := 1;
  WHILE ((Curr_Pos+Limit_In_A_Row-1) <= LENGTH(Str)) DO
    BEGIN

      {*---------------------------------------*}
      {* Quickly look for at least 2 in a row! *}
      {*---------------------------------------*}
      WHILE (((Curr_Pos+Limit_In_A_Row-1) <= LENGTH(Str)) AND
             (Str[Curr_Pos] <> Str[Succ(Curr_Pos)]))
        DO INC(Curr_Pos);

      IF ((Curr_Pos+Limit_In_A_Row-1) <= LENGTH(Str)) THEN
        BEGIN
          i := Curr_Pos+1;
          Same_Chars := TRUE;
          WHILE ((Same_Chars) and (i <= (Curr_Pos+Limit_In_A_Row-1)))
            DO IF (Str[Curr_Pos] <> Str[i])
                 THEN Same_Chars := FALSE
                 ELSE INC(i);

          IF (Same_Chars) THEN
            BEGIN
              Move(Str[Curr_Pos+Limit_In_A_Row-1], Str[Curr_Pos],
                                Length(Str)-(Curr_Pos+Limit_In_A_Row-2));
              Dec(Str[0],Pred(Limit_In_A_Row));
            END
          ELSE Inc(Curr_Pos);
        END; {if}
    END; {while}

  Delete_Duplicate_Chars_In_Str := Str;
end; {delete_duplicate_chars_in_str}

{*
       Note that "Count" is the number of *WORDS* to fill.  So e.g. you'd
use "FillWord(My_Int_Array, SizeOf(My_Int_Array) DIV 2, 1);"
      by Neil Rubenking *}
{**************************************************************}
PROCEDURE FillWord(VAR Dest; Count, What : Word); Assembler;
  ASM
    LES DI, Dest    {ES:DI points to destination}
    MOV CX, Count   {count in CX}
    MOV AX, What    {word to fill with in AX}
    CLD             {forward direction}
    REP STOSW       {perform the fill}
  END; {fillWord}

END. {unit str_stf}